home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / design60.zip / IBMLIB2.INC < prev    next >
Text File  |  1991-05-13  |  8KB  |  281 lines
  1. procedure shrink(v1,v2:String80);
  2. var
  3.    ch : char;
  4.    ndeleted : real;
  5.    s : real;
  6.  
  7. begin
  8.    ndeleted := 0;
  9.    make_window(10,10,70,15,f,b,True);
  10.    s := filesize(d);
  11.    writeln;
  12.    write(' Do you want to dump deleted records? (Y/N) ');
  13.    if not yes then
  14.    begin
  15.       remove_window;
  16.       exit
  17.    end else
  18.    begin
  19.       seek(d,0);
  20.       assign(tempfile,scratch);
  21.       rewrite(tempfile);
  22.       gotoxy(5,3);
  23.       write('Reading record');
  24.       while not eof(d) do
  25.       begin
  26.          read(d,rec);
  27.          gotoxy(21,3);
  28.          write(filepos(d):5);
  29.          with rec do
  30.          if not empty then
  31.          write(tempfile,rec) else
  32.          ndeleted := ndeleted + 1;
  33.       end;
  34.       close(d);
  35.       close(tempfile);
  36.       erase(d);
  37.       rename(tempfile,filename);
  38.       reset(d);
  39.       display_size;
  40.       writeln;
  41.       writeln(' Number of records deleted =',ndeleted:5:0);
  42.       write(' Press any key...');
  43.       display_size;
  44.       clock;
  45.       Ch := ReadKey;
  46.       remove_window
  47.    end;
  48. end;
  49.  
  50. procedure backup;
  51. var
  52.   disk, ch : char;
  53.   destfile : file of recs;
  54.   recnum : Integer;
  55.   add : boolean;
  56.  
  57. begin
  58.    make_window(10,5,70,20,f,b,True);
  59.    write(' Copy <F>rom floppy, or <T>o floppy? ');
  60.    repeat
  61.       Ch := ReadKey;
  62.       ch := upcase(ch);
  63.    until ch in ['F','T'];
  64.    writeln;
  65.    if ch = 'T' then
  66.    begin
  67.       writeln;
  68.       write(' Destination drive for data? (A or B) ');
  69.       repeat
  70.          Disk := UpCase(ReadKey);
  71.       until disk in ['A','B'];
  72.       write(disk+':'); writeln;
  73.       write(' Insert disk ',disk,': and press any key or ESC to abort...');
  74.       Ch := ReadKey;
  75.       writeln;
  76.       if ch <> ESC then
  77.       begin
  78.          clrscr;
  79.          write(' Copying Database ');
  80.          recnum := 1;
  81.          seek(d,recnum - 1);
  82.          assign(destfile,disk+':'+filename);
  83.          rewrite(destfile);
  84.          clrscr;
  85.          gotoxy(2,3); write('Copying Record');
  86.          while not eof(d) do
  87.          begin
  88.            gotoxy(17,3);
  89.            write(recnum:4);
  90.            read(d,rec);
  91.            write(destfile,rec);
  92.            recnum := succ(recnum);
  93.            if free(disk) <= 1000 then
  94.            begin
  95.               close(destfile);
  96.               writeln;
  97.               beep;
  98.               writeln(' Diskette full!');
  99.               writeln(' Insert next diskette and press any key,');
  100.               write(' or ESC to abort...');
  101.               Ch := ReadKey;
  102.               if ch = ESC then
  103.               begin
  104.                  remove_window;
  105.                  exit
  106.               end;
  107.               clrscr;
  108.               rewrite(destfile);
  109.               gotoxy(2,3); write('Copying Record');
  110.            end;
  111.         end;
  112.         close(destfile);
  113.       end;
  114.       end else
  115.       begin
  116.          recnum := 0;
  117.          clrscr;
  118.          writeln(' Do you want to <A>dd to present database, or');
  119.          write(' start with a   <N>ew database? (A/N) ');
  120.          repeat
  121.             Ch := ReadKey;
  122.             ch := upcase(ch);
  123.          until ch in ['A','N'];
  124.          if ch = 'A' then
  125.          begin
  126.             add := true;
  127.             write('Add')
  128.          end else
  129.          begin
  130.             add := false;
  131.             writeln('New');
  132.             writeln;
  133.             if exist(filename) then
  134.             begin
  135.                beep;
  136.                write('WARNING! This will erase the database. '+
  137.                'Are you sure? (Y/N) ');
  138.                if not yyes then
  139.                begin
  140.                   remove_window;
  141.                   exit
  142.                end;
  143.             end; { Exist }
  144.          end;
  145.          writeln;
  146.          write(' Disk to copy from? (A or B) ');
  147.          Disk := UpCase(ReadKey); write(disk,':'); writeln;
  148.          writeln(' Insert each disk in sequence to copy. Make sure');
  149.          writeln(' you don''t insert the same one twice.');
  150.          writeln(' Insert first diskette and press any key, or ESC');
  151.          writeln(' to abort...');
  152.          if not add then
  153.          begin
  154.             close(d);
  155.             rewrite(d);
  156.             recnum := 0;
  157.          end else
  158.          begin
  159.             recnum := filesize(d);
  160.             seek(d,recnum)  { Go to end of file to add }
  161.          end;
  162.          repeat
  163.             Ch := ReadKey;
  164.             if not exist(disk+':'+filename) then
  165.             repeat
  166.                beep;
  167.                writeln;
  168.                writeln(' File not found on ',disk+':');
  169.                writeln(' Insert new disk or press ESC to abort.');
  170.                Ch := ReadKey;
  171.             until (ch = ESC) or exist(disk+':'+filename);
  172.             if ch = ESC then
  173.             begin
  174.                writeln;
  175.                write(' Do you want to sort the new file? (Y/N) ');
  176.                if yyes then
  177.                begin
  178.                   sort;
  179.                   reset(d)
  180.                end;
  181.                remove_window;
  182.                display_size;
  183.                exit
  184.             end;
  185.             assign(destfile,disk+':'+filename);
  186.             reset(destfile);
  187.             clrscr;
  188.             gotoxy(2,3); write('Copying Record');
  189.             while not eof(destfile) do
  190.             begin
  191.                recnum := succ(recnum);
  192.                gotoxy(17,3);
  193.                write(recnum:4);
  194.                read(destfile,rec);
  195.                write(d,rec)
  196.             end;
  197.             close(destfile);
  198.             clrscr;
  199.             Writeln(' Insert next diskette and press any, key or ESC');
  200.             writeln(' to abort...');
  201.         until ch = ESC;
  202.         close(d);
  203.         reset(d);
  204.      end;
  205.      display_size;
  206.    remove_window
  207. end;
  208.  
  209. { -------------------------------------------------------- }
  210. procedure pad(var line:String80; lnth:Integer);
  211. begin
  212.    line := line + spaces(lnth-length(line));
  213. end;
  214. { -------------------------------------------------------- }
  215. procedure remove_spaces(var s:String80);
  216. var
  217.    temp : String80;
  218.    i, n : Integer;
  219.  
  220. begin
  221.    n := length(s);
  222.    temp := '';
  223.    for i := 1 to n do
  224.    if s[i] <> #32 then
  225.    temp := concat(temp,s[i]);
  226.    s := temp
  227. end;
  228.  
  229. function match(str1,str2:String80):boolean;
  230. var
  231.    n : Integer;
  232.    temp : String80;
  233.    tempmatch : boolean;
  234.    ch : char;
  235.  
  236. begin
  237.    str1 := uppercase(str1);
  238.    str2 := uppercase(str2);
  239.    remove_spaces(str1);
  240.    remove_spaces(str2);
  241.    n := length(str1);
  242.    if (pos('<',str1) > 0) or
  243.       (pos('>',str1) > 0) then
  244.       n := pred(n);
  245.    if (pos('=',str1) > 0) then
  246.       n := pred(n);
  247.    temp := copy(str2,1,n);
  248.    tempmatch := str1 = temp;
  249.    if blank(str1) then
  250.    tempmatch := true;
  251.    if (pos('>=',str1) = 1) and not tempmatch then
  252.       begin
  253.          str1 := copy(str1,3,n);
  254.          if str1 <= copy(temp,1,n) then tempmatch := true;
  255.       end;
  256.    if (pos('<=',str1) = 1) and not tempmatch then
  257.       begin
  258.          str1 := copy(str1,3,n);
  259.          if str1 >= copy(temp,1,n) then tempmatch := true;
  260.       end;
  261.    if (pos('>',str1) = 1) and not tempmatch then
  262.       begin
  263.          str1 := copy(str1,2,n);
  264.          if str1 < copy(temp,1,n) then tempmatch := true;
  265.       end;
  266.    if (pos('<',str1) = 1) and not tempmatch then
  267.       begin
  268.          str1 := copy(str1,2,n);
  269.          if str1 > copy(temp,1,n) then tempmatch := true;
  270.       end;
  271.    match := tempmatch;
  272. end;
  273.  
  274. function abort:boolean;
  275. begin
  276.    make_window(20,10,60,13,f,b,True);
  277.    write(' Abort printing? (Y/N) ');
  278.    abort := yyes;
  279.    remove_window
  280. end;
  281.